home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
007
/
facilis2.arc
/
INTERPRT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1980-01-01
|
36KB
|
1,205 lines
{ Facilis 0.31 file: INTERPRT.PAS }
{$R-}
overlay procedure interpret;
var
b,b0: integer; { base index }
h1,h2,h3,h4,h5,h6: integer; { temporaries }
blkcnt, chrcnt: integer; { counters }
jumpbase: integer; { address of jump table }
sbuff: string[80];
ps: (run,fin,stkchk,caschk,divchk,inxchk,redchk,strchk,fnchk,syschk);
fld : array [1..4] of integer; { default field widths }
s : array [0..stacksize] of { blockmark: }
record
case cn:types of { s[b+0] = fct result }
ints: ( i: integer); { s[b+1] = return adr }
reals: ( r: real); { s[b+2] = static link }
bools: ( b: boolean); { s[b+3] = dynamic link }
chars: ( c: char); { s[b+4] = table index }
strngs:(s,p: integer); { s[b+5] = string ptr }
end;
procedure dump;
var p,h3 :integer;
begin
h3:=tab[h2].lev;
writeln(psout);writeln(psout);
writeln(psout,' calling ',tab[h2].name);
writeln(psout,' level ',h3:4);
writeln(psout,' start of code ',pc:4);
writeln(psout);writeln(psout);
writeln(psout,' contents of display '); writeln(psout);
for p:=h3+1 downto 1 do writeln(psout,p:4,display[p]:6);
writeln(psout);writeln(psout);
writeln(psout,' top of stack ',t:4,' frame base ':14,b:4);
writeln(psout);writeln(psout);
writeln(psout,'stack contents':20); writeln(psout);
for p:=t downto 1 do writeln(psout,p:14,s[p].i:8);
writeln(psout,'< = = = >':22)
end; { dump }
function get(var s:integer; t:integer): boolean;
var v:integer;
begin
v := ((t+3) div 16 +1)*16;
if (v < 1) or (v shr 4 > maxavail)
then begin ps := strchk; get := false; end
else begin
get := true;
getmem(spnt,v); s := seg(spnt^);
memw[s:0] := t;
memw[s:2] := v-4;
end
end;
procedure free(p:integer);
begin
tpnt := ptr(p,0);
freemem(tpnt,memw[p:2]+4)
end;
procedure link(j:integer);
var i: integer;
begin
b0 := b;
i := tab[s[b0+4].i].lev;
while j<b0 do begin
b0 := display[i]; i := i-1; end;
s[j].p := s[b0+5].i;
s[b0+5].i := j;
s[j].cn := strngs
end;
function scopy(lf,rt:integer): boolean;
var h1,h2,h3,h4: integer;
begin
scopy := true;
h1 := s[lf].s;
h2 := memw[h1:2];
h3 := s[rt].s;
h4 := memw[h3:0];
if (h1 = 0) or (h2 < h4) or (h2 >= h4+16)
then begin
if h1=0 then link(lf)
else if h2<>0 then free(h1);
if not get(h1,h4) then scopy := false;
s[lf].s := h1;
end else memw[h1:0] := h4;
if ps = run then move(mem[h3:4],mem[h1:4],h4)
end;
label start,loop,windup,
0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,
27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,
51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,
75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,
99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,
117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,
135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,
153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,
171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,
189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,
207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,
225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,
243,244,245,246,247,248,249,250,251,252,253,254,255;
begin { interpret }
inline( { find base address of jump table }
$b8/*+12/ { MOV AX,*+12 }
$89/$86/jumpbase ); { MOV [BP]jumpbase,AX }
goto start;
goto windup;
{ each of these GOTOs compiles to a JMP to one of the interpreter routines }
goto 0;goto 1;goto 2;goto 3;goto 4;goto 5;goto 6;goto 7;
goto 8;goto 9;goto 10;goto 11;goto 12;goto 13;goto 14;goto 15;
goto 16;goto 17;goto 18;goto 19;goto 20;goto 21;goto 22;goto 23;
goto 24;goto 25;goto 26;goto 27;goto 28;goto 29;goto 30;goto 31;
goto 32;goto 33;goto 34;goto 35;goto 36;goto 37;goto 38;goto 39;
goto 40;goto 41;goto 42;goto 43;goto 44;goto 45;goto 46;goto 47;
goto 48;goto 49;goto 50;goto 51;goto 52;goto 53;goto 54;goto 55;
goto 56;goto 57;goto 58;goto 59;goto 60;goto 61;goto 62;goto 63;
goto 64;goto 65;goto 66;goto 67;goto 68;goto 69;goto 70;goto 71;
goto 72;goto 73;goto 74;goto 75;goto 76;goto 77;goto 78;goto 79;
goto 80;goto 81;goto 82;goto 83;goto 84;goto 85;goto 86;goto 87;
goto 88;goto 89;goto 90;goto 91;goto 92;goto 93;goto 94;goto 95;
goto 96;goto 97;goto 98;goto 99;goto 100;goto 101;goto 102;goto 103;
goto 104;goto 105;goto 106;goto 107;goto 108;goto 109;goto 110;goto 111;
goto 112;goto 113;goto 114;goto 115;goto 116;goto 117;goto 118;goto 119;
goto 120;goto 121;goto 122;goto 123;goto 124;goto 125;goto 126;goto 127;
goto 128;goto 129;goto 130;goto 131;goto 132;goto 133;goto 134;goto 135;
goto 136;goto 137;goto 138;goto 139;goto 140;goto 141;goto 142;goto 143;
goto 144;goto 145;goto 146;goto 147;goto 148;goto 149;goto 150;goto 151;
goto 152;goto 153;goto 154;goto 155;goto 156;goto 157;goto 158;goto 159;
goto 160;goto 161;goto 162;goto 163;goto 164;goto 165;goto 166;goto 167;
goto 168;goto 169;goto 170;goto 171;goto 172;goto 173;goto 174;goto 175;
goto 176;goto 177;goto 178;goto 179;goto 180;goto 181;goto 182;goto 183;
goto 184;goto 185;goto 186;goto 187;goto 188;goto 189;goto 190;goto 191;
goto 192;goto 193;goto 194;goto 195;goto 196;goto 197;goto 198;goto 199;
goto 200;goto 201;goto 202;goto 203;goto 204;goto 205;goto 206;goto 207;
goto 208;goto 209;goto 210;goto 211;goto 212;goto 213;goto 214;goto 215;
goto 216;goto 217;goto 218;goto 219;goto 220;goto 221;goto 222;goto 223;
goto 224;goto 225;goto 226;goto 227;goto 228;goto 229;goto 230;goto 231;
goto 232;goto 233;goto 234;goto 235;goto 236;goto 237;goto 238;goto 239;
goto 240;goto 241;goto 242;goto 243;goto 244;goto 245;goto 246;goto 247;
goto 248;goto 249;goto 250;goto 251;goto 252;goto 253;goto 254;goto 255;
start:
s[1].i := 0; s[2].i := 0;
s[3].i := -1; s[4].i := btab[1].last;
display[1] := 0; t := btab[2].vsize - 1;
b := 0; pc := tab[s[4].i].adr;
chrcnt := 0; ps := run;
fld[1] := 8; fld[2] := 20;
fld[3] := 8; fld[4] := 1;
if t > stacksize
then begin
ps := stkchk; goto windup; end;
fillchar(s[5],(t-4)*sizeof(s[1]),0);
loop: { here starts the main loop of the interpreter }
Inline(
$8B/$3E/pc { MOV DI,pc ;get program counter }
/$FF/$06/pc { INC (W)pc }
/$D1/$E7 { SHL DI,=1 ;*4 (bytes per p-code) }
/$D1/$E7 { SHL DI,=1 ;index into code array }
/$81/$C7/code { ADD DI,=code ;leave ptr to p-code in DI }
/$8B/$45/2 { MOV AX,[DI]2 ;get y operand }
/$A3/y { MOV y,AX }
/$8A/$1D { MOV BL,[DI] ;get opcode }
/$88/$1E/opcode { MOV opcode,BL }
/$32/$FF { XOR BH,BH ;leave opcode in BX }
/$8B/$F3 { MOV SI,BX ;*3 (bytes per JMP) }
/$03/$F3 { ADD SI,BX }
/$03/$F3 { ADD SI,BX }
/$03/$B6/jumpbase { ADD SI,[BP]jumpbase ;index into jump table }
/$FF/$E6 { JMP SI ;jump through table }
);
0: { load address }
inline(
$8A/$45/1 { MOV AL,[DI]1 ;get x operand }
/$A2/x ); { MOV x,AL }
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].i := display[x] + y;
goto loop;
1: { load value }
inline(
$8A/$45/1 { MOV AL,[DI]1 ;get x operand }
/$A2/x ); { MOV x,AL }
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t] := s[display[x] + y];
goto loop;
2: { load indirect }
inline(
$8A/$45/1 { MOV AL,[DI]1 ;get x operand }
/$A2/x ); { MOV x,AL }
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t] := s[s[display[x] + y].i];
goto loop;
3: { update display }
inline(
$8A/$45/1 { MOV AL,[DI]1 ;get x operand }
/$A2/x ); { MOV x,AL }
h1 := y; h2 := x; h3 := b;
repeat
display[h1] := h3; h1 := h1-1; h3 := s[h3+2].i
until h1 = h2;
goto loop;
4:5:6: ps := syschk; goto windup;
7: case y and 3 of { concatenation }
0: begin {char+char}
if not get(h1,2) then goto windup;
mem[h1:4] := s[t-1].i;
mem[h1:5] := s[t].i;
t := t-1;
s[t].i := h1;
end;
1: begin {string+char}
h1 := s[t-1].i;
h2 := memw[h1:0];
if not get(h3,h2+1) then goto windup;
move(mem[h1:4],mem[h3:4],h2);
if (y and 4) = 4 then free(h1);
mem[h3:h2+4] := s[t].i;
t := t-1;
s[t].i := h3;
end;
2: begin {char+string}
h1 := s[t].i;
h2 := memw[h1:0];
if not get(h4,h2+1) then goto windup;
move(mem[h1:4],mem[h4:5],h2);
mem[h4:4] := s[t-1].i;
if (y and 8) = 8 then free(h1);
t := t-1;
s[t].i := h4;
end;
3: begin {string+string}
h5 := s[t-1].i;
h6 := s[t].i;
h3 := memw[h5:0];
h4 := memw[h6:0];
if not get(h2,h3+h4) then goto windup;
move(mem[h5:4],mem[h2:4],h3);
move(mem[h6:4],mem[h2:h3+4],h4);
if (y and 4) = 4 then free(h5);
if (y and 8) = 8 then free(h6);
t := t-1;
s[t].i := h2;
end;
end;
goto loop;
8: if y < 10 then
case y of
0: s[t].i := abs(s[t].i);
1: s[t].r := abs(s[t].r);
2: s[t].i := sqr(s[t].i);
3: s[t].r := sqr(s[t].r);
4: s[t].b := odd(s[t].i);
5: s[t].c := chr(s[t].i);
6: s[t].i := ord(s[t].c);
7: s[t].c := succ(s[t].c);
8: s[t].c := pred(s[t].c);
9: s[t].i := round(s[t].r);
end
else if y < 20 then
case y of
10: s[t].i := trunc(s[t].r);
11: s[t].r := sin(s[t].r);
12: s[t].r := cos(s[t].r);
13: s[t].r := exp(s[t].r);
14: if s[t].r <= 0
then begin
ps := fnchk; goto windup; end
else s[t].r := ln(s[t].r);
15: if s[t].r < 0
then begin
ps := fnchk; goto windup; end
else s[t].r := sqrt(s[t].r);
16: s[t].r := arctan(s[t].r);
17: begin
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].b := eof(prd)
end;
18: begin
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].b := eoln(prd)
end;
19: begin
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].i := maxavail
end;
end
else if y < 33 then
case y of
20: s[t].i := memw[s[t].i:0];
21: begin
h1 := s[t].i;
s[t].i := memw[h1:0];
spnt := ptr(h1,0); freemem(spnt,memw[h1:2]+4)
end;
22: s[t].i := 1;
23: begin
h1 := s[t-2].i;
h4 := memw[h1:0];
h2 := s[t-1].i;
if (h2 < 1) or (h2 > h4)
then begin h4 := 0; h2 := 2; end;
h3 := s[t].i;
if h3 > h4-h2+1 then h3 := h4-h2+1;
if h3 < 0 then h3 := 0;
if not get(h5,h3) then goto windup;
move(mem[h1:h2+3],mem[h5:4],h3);
s[t-2].i := h5;
t := t-2;
end;
24: begin
h1 := s[t-2].i;
h4 := memw[h1:0];
h2 := s[t-1].i;
if (h2 < 1) or (h2 > h4)
then memw[h1:0] := 0
else begin
h3 := s[t].i;
if h3 > h4-h2+1 then h3 := h4-h2+1;
if h3 < 0 then h3 := 0;
move(mem[h1:h2+3],mem[h1:4],h3);
memw[h1:0] := h3;
end;
t := t-2;
end;
25: begin
if not get(h1,1) then goto windup;
if (s[t-1].i = 1) and (s[t].i > 0)
then mem[h1:4] := s[t-2].i
else memw[h1:0] := 0;
s[t-2].i := h1;
t := t-2;
end;
26,27,30,31:
begin
h1 := s[t-1].i;
h2 := s[t].i; t := t-1;
h6 := memw[h1:0]+4;
h3 := memw[h2:0]+5-h6;
if (h3<=0) or (h6=4)
then s[t].i := 0
else begin
h4 := 0;
while h4<h3 do begin
h5 := 4;
while (h5<h6) and (mem[h1:h5]=mem[h2:h4+h5]) do h5 := h5+1;
if h5=h6 then h3:=h4-1 else h4 := h4+1;
end;
if h3=h4 then s[t].i := 0 else s[t].i := h4+1;
end;
if odd(y) then free(h1);
if y > 29 then free(h2);
end;
28,32: begin
h1 := s[t-1].i;
h2 := s[t].i;
h3 := memw[h2:0]+4;
h4 := 4;
while (h4<h3) and (mem[h2:h4]<>h1) do h4 := h4+1;
if y=32 then free(h3);
t := t-1;
if h4<h3 then s[t].i := h4-3 else s[t].i := 0;
end;
end
else if y < 40 then
case y of
33,34: begin
if y=34 then str(s[t].r:18,sbuff)
else str(s[t].i:1,sbuff);
h2 := length(sbuff);
if not get(h1,h2) then goto windup;
move(sbuff[1],mem[h1:4],h2);
s[t].i := h1
end;
35,36,37,38:
begin
h1 := s[t].i;
h2 := memw[h1:0]; sbuff := '';
move(mem[h1:4],sbuff[1],h2);
sbuff[0] := chr(h2);
if y < 37 then val(sbuff,s[t].i,h5)
else val(sbuff,s[t].r,h5);
if not odd(y) then free(h1)
end;
39: begin
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].b := keypressed
end;
end
else if y < 50
then case y of
40: begin
h1 := s[t].i;
if h1 < 1
then begin
ps := fnchk; goto windup; end
else s[t].i := random(h1);
end;
41: begin
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].r := random
end;
42: s[t].c := upcase(s[t].c);
43: randomize;
44: clrscr;
45: begin
h1 := s[t-1].i;
h2 := s[t].i;
if (h1<1) or (h1>80) or (h2<1) or (h2>25)
then begin
ps := fnchk; goto windup; end
else begin
gotoxy(h1,h2);
chrcnt := h1;
t := t-2;
end;
end;
46: begin
textcolor(s[t].i);
t := t-1;
end;
47: begin
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else begin
Inline(
$B2/$FF { MOV DL,=$FF }
/$B4/$06 { MOV AH,=6 ;DOS function 6 }
/$CD/$21 { INT $21 }
/$74/$0C { JZ notready }
/$A8/$FF { TEST AL,=$FF }
/$74/$10 { JZ extend }
/$C7/$86/h1/$01/$00 { MOV (W)[BP]h1,=1 ;got a char }
/$EB/$10 { JMP (S)end }
{ notready: }
/$C7/$86/h1/$00/$00 { MOV (W)[BP]h1,=0 ;no char }
/$EB/$08 { JMP (S)end }
{ extend: ;extended code }
/$CD/$21 { INT $21 ;get another }
/$C7/$86/h1/$02/$00 { MOV (W)[BP]h1,=2 }
{ end: ;return length in h1 }
/$32/$E4 { XOR AH,AH ; char code in h2 }
/$89/$86/h2 ); { MOV [BP]h2,AX }
if not get(h3,h1) then goto windup;
if h1=1 then mem[h3:4] := h2 else mem[h3:4] := 0;
mem[h3:5] := h2;
s[t].i := h3
end
end;
48: begin
t := t+1;
s[t].i := wherex;
end;
49: begin
t := t+1;
s[t].i := wherey;
end;
end
else if y < 60
then case y of
50: begin
delay(s[t].i);
t := t-1;
end;
51: begin
textbackground(s[t].i);
t := t-1;
end;
52: begin
sound(s[t].i);
t := t-1;
end;
53: nosound;
end
else begin
ps := syschk; goto windup;
end;
goto loop; { end of functions }
9: s[t].i := s[t].i + y; { offset }
goto loop;
10: pc := y; { jump }
goto loop;
11: { conditional jump }
if not s[t].b then pc := y;
t := t-1;
goto loop;
12: { switch }
h1 := s[t].i; t := t-1;
h2 := y; h3 := 0;
repeat
if code[h2].f <> 13
then begin
ps := caschk; goto windup; end
else if code[h2].y = h1
then begin
h3 := 1;
pc := code[h2+1].y
end else h2 := h2 + 2
until h3 <> 0;
goto loop;
13: ps := syschk; goto windup; {case marker}
14: { for1up }
h1 := s[t-1].i;
if h1 <= s[t].i
then s[s[t-2].i].i := h1
else begin
t := t-3;
pc := y
end;
goto loop;
15: { for2up }
h2 := s[t-2].i;
h1 := s[h2].i +1;
if h1 <= s[t].i
then begin
s[h2].i := h1; pc := y
end else t := t-3;
goto loop;
16: { for1down }
h1 := s[t-1].i;
if h1 >= s[t].i
then s[s[t-2].i].i := h1
else begin
pc := y; t := t-3
end;
goto loop;
17: { for2down }
h2 := s[t-2].i;
h1 := s[h2].i - 1;
if h1 >= s[t].i
then begin
s[h2].i := h1; pc := y
end else t := t-3;
goto loop;
18: { mark stack }
h1 := btab[tab[y].ref].vsize;
if t+h1 > stacksize
then begin
ps := stkchk; goto windup; end
else begin
t := t+6; b0 := t; s[b0].i := 0;
s[t-2].i := h1-1; s[t-1].i := y
end;
goto loop;
19: { call }
h1 := t - y; { h1 points to base }
h2 := s[h1+4].i; { h2 points to tab }
h3 := tab[h2].lev; display[h3+1] := h1;
h4 := s[h1+3].i + h1;
s[h1+1].i := pc; s[h1+2].i := display[h3];
s[h1+3].i := b;
fillchar(s[t+1],(h4-t)*sizeof(s[1]),0);
b := h1; t := h4;
pc := tab[h2].adr;
if stackdump then dump;
goto loop;
20: { index1 }
h1 := y; { h1 points to atab }
h2 := atab[h1].low;
h3 := s[t].i;
if h3 < h2
then begin
ps := inxchk; goto windup; end
else if h3 > atab[h1].high
then begin
ps := inxchk; goto windup; end
else begin
t := t-1;
s[t].i := s[t].i + (h3-h2)
end;
goto loop;
21: { index }
h1 := y; { h1 points to atab }
h2 := atab[h1].low;
h3 := s[t].i;
if h3 < h2
then begin
ps := inxchk; goto windup; end
else if h3 > atab[h1].high
then begin
ps := inxchk; goto windup; end
else begin
t := t-1;
s[t].i := s[t].i + (h3-h2)*atab[h1].elsize
end;
goto loop;
22: { load block }
h1 := s[t].i; t := t-1;
h2 := y + t;
if h2 > stacksize
then begin
ps := stkchk; goto windup; end
else while t < h2 do
begin
t := t+1;
if s[h1].cn = strngs
then begin
s[t].s := 0;
if not scopy(t,h1) then goto windup; end
else s[t] := s[h1];
h1 := h1+1
end;
goto loop;
23: { copy block }
h1 := s[t-1].i;
h2 := s[t].i;
h3 := h1 + y;
while h1 < h3 do
begin
if s[h2].cn = strngs
then begin
s[h1].s := 0;
if not scopy(h1,h2) then goto windup; end
else s[h1] := s[h2];
h1 := h1+1; h2 := h2+1
end;
t := t-2;
goto loop;
24: { literal }
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].i := y;
goto loop;
25: { load real }
t := t+1;
if t > stacksize
then begin
ps := stkchk; goto windup; end
else s[t].r := rconst[y];
goto loop;
26: { float }
h1 := t - y;
s[h1].r := s[h1].i;
goto loop;
27: { read }
case y of
1: read(prd,s[s[t].i].i);
2: read(prd,s[s[t].i].r);
4: read(prd,s[s[t].i].c);
5: begin
read(prd,sbuff);
h1 := length(sbuff);
if h1=0
then h3 := nul
else begin
if not get(h3,h1) then goto windup;
move(sbuff[1],mem[h3:4],h1);
end;
h4 := s[t].i; h5 := s[h4].i;
if h5 = 0 then link(h4)
else if memw[h5:2] <> 0 then free(h5);
s[h4].i := h3;
end
end ;
t := t-1;
goto loop;
28: ps := syschk; goto windup;
29: { write1 }
chrcnt := chrcnt + fld[y];
if chrcnt > lineleng
then begin
writeln(prr); chrcnt := 0; end;
case y of
1: write(prr,s[t].i: fld[1]);
2: write(prr,s[t].r: fld[2]);
3: if s[t].b then write ('true':fld[3])
else write ('false':fld[3]);
4: write(prr,chr(s[t].i));
end ;
if chrcnt = lineleng then chrcnt := 0;
t := t-1;
goto loop;
30: { write2 }
chrcnt := chrcnt + s[t].i;
if chrcnt > lineleng
then begin
writeln(prr); chrcnt := 0; end;
case y of
1: write(prr,s[t-1].i: s[t].i);
2: write(prr,s[t-1].r: s[t].i);
3: if s[t-1].b then write ('true') else write ('false');
4: write(prr,chr(s[t-1].i): s[t].i);
end ;
if chrcnt = lineleng then chrcnt := 0;
t := t-2;
goto loop;
31: { chars := strngs }
h1 := s[t].i;
if memw[h1:0] <> 1
then begin
ps := strchk; goto windup; end
else begin
s[s[t-1].i].i := mem[h1:4];
if (y and 8) = 8 then free(h1)
end;
t := t-2;
goto loop;
32: { string relations }
h2 := s[t-1].i;
h3 := s[t].i;
case y and 3 of
1: begin {strngs~chars}
h4 := memw[h2:0];
if h4=0 then h5 := 64
else if h3>mem[h2:4] then h5 := 64
else if h3<mem[h2:4] then h5 := 32
else if h4=1 then h5 := 16
else h5 := 32;
end;
2: begin {chars~strngs}
h4 := memw[h3:0];
if h4=0 then h5 := 32
else if h2>mem[h3:4] then h5 := 32
else if h2<mem[h3:4] then h5 := 64
else if h4=1 then h5 := 16
else h5 := 64;
end;
3: begin {strngs~strngs}
h4 := memw[h2:0]; h1 :=0;
h5 := memw[h3:0];
if h5<h4 then h4 := h5 else h5 := h4;
while h1<h4 do begin
if mem[h2:4+h1] <> mem[h3:4+h1]
then h4 := h1
else h1 := h1+1;
end;
if h4=h5
then if memw[h2:0]=memw[h3:0]
then h5 := 16
else if memw[h2:0]<memw[h3:0]
then h5 := 64 else h5 := 32
else if mem[h2:4+h1]<mem[h3:4+h1]
then h5 := 64 else h5 := 32;
end;
end;
if (y and 5) = 5 then free(h2);
if (y and 10) = 10 then free(h3);
t := t-1;
s[t].b := (y and h5) > 0;
goto loop;
33:34:35:36:37:38:39:40:41:42:43:44:45:46:47:48:49:50:51:52:53:54:55:56:57:
58:59:60:61:62:63:64:65:66:67:68:69:70:71:72:73:74:75:76:77:78:79:80:81:82:
83:84:85:86:87:88:89:90:91:92:93:94:95:96:97:98:99:100:101:102:103:104:105:
106:107:108:109:110:111:112:113:114:115:116:117:118:119:120:121:122:123:124:
125:126:127:128:129:130: ps := syschk; goto windup;
131: ps := fin;
goto windup;
132: { exit procedure }
h1 := s[b+5].i;
while h1 <> 0 do begin
free(s[h1].i);
h1 := s[h1].p; end;
t := b-1;
pc := s[b+1].i; b := s[b+3].i;
goto loop;
133: { exit function }
h1 := s[b+5].i;
while h1 <> 0 do begin
free(s[h1].i);
h1 := s[h1].p; end;
t := b;
pc := s[b+1].i; b := s[b+3].i;
goto loop;
134: s[t] := s[s[t].i]; goto loop;
135: s[t].b := not s[t].b; goto loop;
136: s[t].i := - s[t].i; goto loop;
137:
chrcnt := chrcnt + s[t-1].i;
if chrcnt > lineleng
then begin
writeln(prr); chrcnt := 0; end
else write(prr,s[t-2].r: s[t-1].i: s[t].i);
if chrcnt = lineleng then chrcnt := 0;
t := t-3;
goto loop;
138: { store }
s[s[t-1].i] := s[t];
t := t-2;
goto loop;
139:
t := t-1;
s[t].b := s[t].r = s[t+1].r;
goto loop;
140:
t := t-1;
s[t].b := s[t].r <> s[t+1].r;
goto loop;
141:
t := t-1;
s[t].b := s[t].r < s[t+1].r;
goto loop;
142:
t := t-1;
s[t].b := s[t].r <= s[t+1].r;
goto loop;
143:
t := t-1;
s[t].b := s[t].r > s[t+1].r;
goto loop;
144:
t := t-1;
s[t].b := s[t].r >= s[t+1].r;
goto loop;
145:
t := t-1;
s[t].b := s[t].i = s[t+1].i;
goto loop;
146:
t := t-1;
s[t].b := s[t].i <> s[t+1].i;
goto loop;
147:
t := t-1;
s[t].b := s[t].i < s[t+1].i;
goto loop;
148:
t := t-1;
s[t].b := s[t].i <= s[t+1].i;
goto loop;
149:
t := t-1;
s[t].b := s[t].i > s[t+1].i;
goto loop;
150:
t := t-1;
s[t].b := s[t].i >= s[t+1].i;
goto loop;
151:
t := t-1;
s[t].b := s[t].b or s[t+1].b;
goto loop;
152:
t := t-1;
s[t].i := s[t].i + s[t+1].i;
goto loop;
153:
t := t-1;
s[t].i := s[t].i - s[t+1].i;
goto loop;
154:
t := t-1;
s[t].r := s[t].r + s[t+1].r;
goto loop;
155:
t := t-1;
s[t].r := s[t].r - s[t+1].r;
goto loop;
156:
t := t-1;
s[t].b := s[t].b and s[t+1].b;
goto loop;
157:
t := t-1;
s[t].i := s[t].i * s[t+1].i;
goto loop;
158:
t := t-1;
if s[t+1].i = 0
then begin
ps := divchk; goto windup; end
else s[t].i := s[t].i div s[t+1].i;
goto loop;
159:
t := t-1;
if s[t+1].i = 0
then begin
ps := divchk; goto windup; end
else s[t].i := s[t].i mod s[t+1].i;
goto loop;
160:
t := t-1;
s[t].r := s[t].r * s[t+1].r;
goto loop;
161:
t := t-1;
s[t].r := s[t].r / s[t+1].r;
goto loop;
162: if eof(prd)
then begin
ps := redchk; goto windup; end
else readln;
goto loop;
163:
writeln(prr);
chrcnt := 0;
goto loop;
164: s[t].r := - s[t].r; goto loop;
165: { index strngs }
h1 := s[t-1].i;
h2 := s[t].i;
if (h2 <= 0) or (h2 > memw[h1:0])
then begin
ps := inxchk; goto windup; end
else begin
t := t-1;
s[t].i := mem[h1:h2+3]
end;
goto loop;
166: { strngs := temp }
h2 := s[t-1].i;
h1 := s[h2].i;
if h1=0 then link(h2)
else if memw[h1:2] <> 0 then free(h1);
s[h2].i := s[t].i;
t := t-2;
goto loop;
167: { convert array to string }
h1 := s[t].i;
if not get(h3,y) then goto windup;
for h4 := 0 to y-1 do mem[h3:4+h4] := ord(s[h1+h4].c);
s[t].i := h3;
goto loop;
168: { strngs := chars }
h2 := s[s[t-1].i].i;
if (h2=0) or (memw[h2:2] > 12) then begin
if not get(h3,1) then goto windup;
if h2=0 then link(s[t-1].i) else free(h2);
h2 := h3;
s[s[t-1].i].i := h2; end;
mem[h2:4] := s[t].i;
memw[h2:0] := 1;
t := t-2;
goto loop;
169: { strngs := strngs }
if not scopy(s[t-1].i, t) then goto windup;
t := t-2;
goto loop;
170: 171: { write string }
h3 := s[t].i; t := t-1;
h2 := memw[h3:0] + 4;
h1 := 4;
while h1 < h2 do begin
write(prr,chr(mem[h3:h1]));
h1 := h1+1;
end;
if opcode = 171 then free(h3);
chrcnt := (chrcnt + h2 -4) mod lineleng;
goto loop;
172: { string val param }
h1 := s[t].i;
h4 := memw[h1:0];
if not get(h2,h4) then goto windup;
move(mem[h1:4],mem[h2:4],h4);
s[t].i := h2;
s[t].p := s[b0].i;
s[b0].i := t;
goto loop;
173: { temp val param }
s[t].p := s[b0].i;
s[b0].i := t;
goto loop;
174: 175: { chararray := string }
h1 := s[t].i;
h2 := memw[h1:0];
h4 := s[t-1].i;
if h2>=y
then for h3 := 0 to y-1 do s[h4+h3].c := chr(mem[h1:4+h3])
else begin
for h3 := 0 to h2-1 do s[h4+h3].c := chr(mem[h1:4+h3]);
for h3 := h4+h2 to h4+y-1 do s[h3].c := ' '
end;
if opcode=175 then free(h1);
t := t-2;
goto loop;
176: 177: { write string - defined field }
h4 := s[t].i;
h3 := s[t-1].i;
h2 := memw[h3:0];
if h2>=h4 then h2 := h4
else repeat
write(prr,' ');
h4 := h4-1;
until h4=h2;
h1 := 4; h2 := h2+4;
while h1 < h2 do begin
write(prr,chr(mem[h3:h1]));
h1 := h1+1
end;
if opcode=177 then free(h3);
if chrcnt = 0 then chrcnt := s[t].i mod lineleng;
t := t-2;
goto loop;
178:179:180:181:182:183:184:185:186:187:188:189:190:191:192:193:194:195:196:
197:198:199:200:201:202:203:204:205:206:207:208:209:210:211:212:213:214:215:
216:217:218:219:220:221:222:223:224:225:226:227:228:229:230:231:232:233:234:
235:236:237:238:239:240:241:242:243:244:245:246:247:248:249:250:251:252:253:
254:255: ps := syschk; goto windup;
windup:
if ps <> fin
then begin
writeln(prr);
write(prr,' halt at', pc-1:5, ' because of ');
case ps of
caschk: writeln(prr,'undefined case');
divchk: writeln(prr,'division by 0');
inxchk: writeln(prr,'invalid index');
stkchk: writeln(prr,'storage overflow');
redchk: writeln(prr,'reading past end of file');
strchk: writeln(prr,'string length error');
fnchk: writeln(prr,'function argument out of range');
syschk: writeln(prr,'bug in compiler');
end ;
h1 := b; blkcnt := 10; { post mortem dump }
repeat
writeln(prr); blkcnt := blkcnt - 1;
if blkcnt = 0 then h1 := 0; h2 := s[h1+4].i;
if h1<>0
then writeln(prr,' ', tab[h2].name, ' called at', s[h1+1].i: 5);
h2 := btab[tab[h2].ref].last;
while h2 <> 0 do
with tab[h2] do
begin
if obj = vvariable
then if typ in stantyps
then begin
write(prr,' ', name, ' = ');
if normal then h3 := h1+adr else h3 := s[h1+adr].i;
case typ of
ints : writeln(prr,s[h3].i);
reals: writeln(prr,s[h3].r);
bools: if s[h3].b
then writeln(prr,'true')
else writeln(prr,'false');
chars: writeln(prr,chr(s[h3].i mod 64));
strngs: begin
h3 := s[h3].i;
write('''');
h4 := memw[h3:0] + 4;
h5 := 4;
while h5 < h4 do begin
write(prr,chr(mem[h3:h5]));
h5 := h5+1;
end;
writeln('''');
end;
end
end ;
h2 := link
end ;
h1 := s[h1+3].i
until h1 < 0;
end ;
writeln(prr);
end ; { interpret }
{$R+}